home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / lib-complete.el.z / lib-complete.el
Encoding:
Text File  |  1998-05-21  |  12.8 KB  |  344 lines
  1. ;;; lib-complete.el --- Completion on the lisp search path
  2.  
  3. ;; Copyright (C) 1997 Free Software Foundation, Inc.
  4. ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
  5.  
  6. ;; Author: Mike Williams <mike-w@cs.aukuni.ac.nz>
  7. ;; Maintainer: XEmacs Development Team
  8. ;; Keywords: lisp, extensions
  9. ;; Created: Sat Apr 20 17:47:21 1991
  10.  
  11. ;; This file is part of XEmacs.
  12.  
  13. ;; XEmacs is free software; you can redistribute it and/or modify it
  14. ;; under the terms of the GNU General Public License as published by
  15. ;; the Free Software Foundation; either version 2, or (at your option)
  16. ;; any later version.
  17.  
  18. ;; XEmacs is distributed in the hope that it will be useful, but
  19. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21. ;; General Public License for more details.
  22.  
  23. ;; You should have received a copy of the GNU General Public License
  24. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  25. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;; Boston, MA 02111-1307, USA.
  27.  
  28. ;;; Synched up with: Not in FSF.
  29.  
  30. ;;; Commentary:
  31.  
  32. ;; ========================================================================
  33. ;; lib-complete.el --  Completion on a search path
  34. ;; Author          : Mike Williams <mike-w@cs.aukuni.ac.nz>
  35. ;; Created On      : Sat Apr 20 17:47:21 1991
  36. ;; Last Modified By: Heiko M|nkel <muenkel@tnt.uni-hannover.de>
  37. ;; Additional XEmacs integration By: Chuck Thompson <cthomp@cs.uiuc.edu>
  38. ;; Last Modified On: Thu Jul 1 14:23:00 1994
  39. ;; RCS Info        : $Revision: 1.7.1 $ $Locker:  $
  40. ;; ========================================================================
  41. ;; NOTE: XEmacs must be redumped if this file is changed.
  42. ;;
  43. ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
  44. ;;
  45. ;; Keywords: utility, lisp
  46.  
  47. ;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his
  48. ;; helpful suggestions.
  49.  
  50. ;; The function locate-file is removed, because of its incompatibility
  51. ;; with the buildin function of the lemacs 19.10 (Heiko M|nkel).
  52.  
  53. ;; There is now the new function find-library in this package.
  54.  
  55. ;;; ChangeLog:
  56.  
  57. ;; 4/26/97: sb Mule-ize.
  58.  
  59. ;;; Code:
  60.  
  61. ;;=== Determine completions for filename in search path ===================
  62.  
  63. (defun library-all-completions (FILE SEARCH-PATH &optional FULL FAST)
  64.   "Return all completions for FILE in any directory on SEARCH-PATH.
  65. If optional third argument FULL is non-nil, returned pathnames should be 
  66.   absolute rather than relative to some directory on the SEARCH-PATH.
  67. If optional fourth argument FAST is non-nil, don't sort the completions,
  68.   or remove duplicates."
  69.   (setq FILE (or FILE ""))
  70.   (if (file-name-absolute-p FILE)
  71.       ;; It's an absolute file name, so don't need SEARCH-PATH
  72.       (progn
  73.     (setq FILE (expand-file-name FILE))
  74.     (file-name-all-completions 
  75.      (file-name-nondirectory FILE) (file-name-directory FILE)))
  76.     (let ((subdir (file-name-directory FILE))
  77.       (file (file-name-nondirectory FILE))
  78.       all-completions)
  79.       ;; Make list of completions in each directory on SEARCH-PATH
  80.       (while SEARCH-PATH
  81.     (let* ((dir (concat (file-name-as-directory 
  82.                  (expand-file-name (car SEARCH-PATH)))
  83.                 subdir))
  84.            (dir-prefix (if FULL dir subdir)))
  85.       (if (file-directory-p dir)
  86.           (let ((subdir-completions 
  87.              (file-name-all-completions file dir)))
  88.         (while subdir-completions
  89.           (setq all-completions 
  90.             (cons (concat dir-prefix (car subdir-completions))
  91.                   all-completions))
  92.           (setq subdir-completions (cdr subdir-completions))))))
  93.     (setq SEARCH-PATH (cdr SEARCH-PATH)))   
  94.       (if FAST all-completions
  95.     (let ((sorted (nreverse (sort all-completions 'string<)))
  96.           compressed)
  97.       (while sorted
  98.         (if (equal (car sorted) (car compressed)) nil
  99.           (setq compressed (cons (car sorted) compressed)))
  100.         (setq sorted (cdr sorted)))
  101.       compressed)))))
  102.  
  103. ;;=== Utilities ===========================================================
  104.  
  105. (defmacro progn-with-message (MESSAGE &rest FORMS)
  106.   "(progn-with-message MESSAGE FORMS ...)
  107. Display MESSAGE and evaluate FORMS, returning value of the last one."
  108.   ;; based on Hallvard Furuseth's funcall-with-message
  109.   (` 
  110.    (if (eq (selected-window) (minibuffer-window))
  111.        (save-excursion
  112.      (goto-char (point-max))
  113.      (let ((orig-pmax (point-max)))
  114.        (unwind-protect
  115.            (progn
  116.          (insert " " (, MESSAGE)) (goto-char orig-pmax)
  117.          (sit-for 0)        ; Redisplay
  118.          (,@ FORMS))
  119.          (delete-region orig-pmax (point-max)))))
  120.      (prog2
  121.       (message "%s" (, MESSAGE))
  122.       (progn (,@ FORMS))
  123.       (message "")))))
  124. #+infodock (defalias 'lib-funcall-with-msg 'progn-with-message)
  125.  
  126. (put 'progn-with-message 'lisp-indent-hook 1)
  127. #+infodock (put 'lib-funcall-with-message 'lisp-indent-hook 1)
  128.  
  129. ;;=== Completion caching ==================================================
  130.  
  131. (defconst lib-complete:cache nil
  132.   "Used within read-library and read-library-internal to prevent 
  133. costly repeated calls to library-all-completions.
  134. Format is a list of lists of the form
  135.  
  136.     ([<path> <subdir>] <cache-record> <cache-record> ...)
  137.  
  138. where each <cache-record> has the form
  139.  
  140.    (<root> <modtimes> <completion-table>)")
  141. #+infodock (defvaralias 'lib-completions 'lib-complete:cache)
  142.  
  143. (defun lib-complete:better-root (ROOT1 ROOT2)
  144.   "Return non-nil if ROOT1 is a superset of ROOT2."
  145.   (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
  146.        (string-match
  147.     (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
  148.     ROOT2)))
  149.  
  150. (defun lib-complete:get-completion-table (FILE PATH FILTER)
  151.   (let* ((subdir (file-name-directory FILE))
  152.      (root (file-name-nondirectory FILE))
  153.      (PATH 
  154.       (mapcar 
  155.        (function (lambda (dir) (file-name-as-directory
  156.                     (expand-file-name (or dir "")))))
  157.        PATH))
  158.      (key (vector PATH subdir FILTER))
  159.      (real-dirs 
  160.       (if subdir
  161.           (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
  162.         PATH))
  163.      (path-modtimes
  164.       (mapcar 
  165.        (function (lambda (fn) (if fn (nth 5 (file-attributes fn))))) 
  166.        real-dirs))
  167.      (cache-entry (assoc key lib-complete:cache))
  168.      (cache-records (cdr cache-entry)))
  169.     ;; Look for cached entry
  170.     (catch 'table
  171.       (while cache-records
  172.     (if (and 
  173.          (lib-complete:better-root (nth 0 (car cache-records)) root)
  174.          (equal (nth 1 (car cache-records)) path-modtimes))
  175.         (throw 'table (nth 2 (car cache-records))))
  176.     (setq cache-records (cdr cache-records)))
  177.       ;; Otherwise build completions
  178.       (let ((completion-list 
  179.          (progn-with-message "(building completion table...)"
  180.            (library-all-completions FILE PATH nil 'fast)))
  181.         (completion-table (make-vector 127 0)))
  182.     (while completion-list
  183.       (let ((completion
  184.          (if (or (not FILTER) 
  185.              (file-directory-p (car completion-list))) 
  186.              (car completion-list)
  187.            (funcall FILTER (car completion-list)))))
  188.         (if completion
  189.         (intern completion completion-table)))
  190.       (setq completion-list (cdr completion-list)))
  191.     ;; Cache the completions
  192.     (lib-complete:cache-completions key root 
  193.                     path-modtimes completion-table)
  194.     completion-table))))
  195.  
  196. (defvar lib-complete:max-cache-size 40 
  197.   "*Maximum number of search paths which are cached.")
  198.  
  199. (defun lib-complete:cache-completions (key root modtimes table)
  200.   (let* ((cache-entry (assoc key lib-complete:cache))
  201.      (cache-records (cdr cache-entry))
  202.      (new-cache-records (list (list root modtimes table))))
  203.     (if (not cache-entry) nil
  204.       ;; Remove old cache entry
  205.       (setq lib-complete:cache (delq cache-entry lib-complete:cache))
  206.       ;; Copy non-redundant entries from old cache entry
  207.       (while cache-records
  208.     (if (or (equal root (nth 0 (car cache-records)))
  209.         (lib-complete:better-root root (nth 0 (car cache-records))))
  210.         nil
  211.       (setq new-cache-records 
  212.         (cons (car cache-records) new-cache-records)))
  213.     (setq cache-records (cdr cache-records))))
  214.     ;; Add entry to front of cache
  215.     (setq lib-complete:cache
  216.       (cons (cons key (nreverse new-cache-records)) lib-complete:cache))
  217.     ;; Trim cache
  218.     (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
  219.       (if tail (setcdr tail nil)))))
  220.  
  221. ;;=== Read a filename, with completion in a search path ===================
  222.  
  223. (defun read-library-internal (FILE FILTER FLAG)
  224.   "Don't call this."
  225.   ;; Relies on read-library-internal-search-path being let-bound
  226.   (let ((completion-table
  227.      (lib-complete:get-completion-table
  228.       FILE read-library-internal-search-path FILTER)))
  229.     (cond
  230.      ((not completion-table) nil)
  231.      ;; Completion table is filtered before use, so the PREDICATE
  232.      ;; argument is redundant.
  233.      ((eq FLAG nil) (try-completion FILE completion-table nil))
  234.      ((eq FLAG t) (all-completions FILE completion-table nil))
  235.      ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
  236.      )))
  237.  
  238. (defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH 
  239.                 FULL FILTER)
  240.   "Read library name, prompting with PROMPT and completing in directories
  241. from SEARCH-PATH.  A nil in the search path represents the current
  242. directory.  Completions for a given search-path are cached, with the
  243. cache being invalidated whenever one of the directories on the path changes.
  244. Default to DEFAULT if user enters a null string.
  245. Optional fourth arg MUST-MATCH non-nil means require existing file's name.
  246.   Non-nil and non-t means also require confirmation after completion.
  247. Optional fifth argument FULL non-nil causes a full pathname, rather than a 
  248.   relative pathname, to be returned.  Note that FULL implies MUST-MATCH.
  249. Optional sixth argument FILTER can be used to provide a function to
  250.   filter the completions.  This function is passed the filename, and should
  251.   return a transformed filename (possibly a null transformation) or nil, 
  252.   indicating that the filename should not be included in the completions."
  253.   (let* ((read-library-internal-search-path SEARCH-PATH)
  254.      (library (completing-read PROMPT 'read-library-internal 
  255.                    FILTER (or MUST-MATCH FULL) nil)))
  256.     (cond 
  257.      ((equal library "") DEFAULT)
  258.      (FULL (locate-file library read-library-internal-search-path
  259.             ;; decompression doesn't work with Mule -slb
  260.             (if (featurep 'mule)
  261.                 ".el:.elc"
  262.               ".el:.el.gz:.elc")))
  263.      (t library))))
  264.  
  265. ;; NOTE: as a special case, read-library may be used to read a filename
  266. ;; relative to the current directory, returning a *relative* pathname
  267. ;; (read-file-name returns a full pathname).
  268. ;;
  269. ;; eg. (read-library "Local header: " '(nil) nil)
  270.  
  271. (defun get-library-path ()
  272.   "Front end to read-library"
  273.   (read-library "Find Library file: " load-path nil t t
  274.           (function (lambda (fn) 
  275.                   (cond
  276.                    ;; decompression doesn't work with mule -slb
  277.                    ((string-match (if (featurep 'mule)
  278.                           "\\.el$"
  279.                         "\\.el\\(\\.gz\\)?$") fn)
  280.                 (substring fn 0 (match-beginning 0))))))
  281.           ))
  282.  
  283. ;;=== Replacement for load-library with completion ========================
  284.  
  285. (defun load-library (library)
  286.   "Load the library named LIBRARY.
  287. This is an interface to the function `load'."
  288.   (interactive 
  289.    (list (read-library "Load Library: " load-path nil nil nil
  290.           (function (lambda (fn) 
  291.                   (cond 
  292.                    ((string-match "\\.elc?$" fn)
  293.                 (substring fn 0 (match-beginning 0))))))
  294.           ))) 
  295.   (load library))
  296.  
  297. ;;=== find-library with completion (Author: Heiko Muenkel) ===================
  298.  
  299. (defun find-library (library &optional codesys)
  300.   "Find and edit the source for the library named LIBRARY.
  301. The extension of the LIBRARY must be omitted.
  302. Under XEmacs/Mule, the optional second argument specifies the
  303. coding system to use when decoding the file.  Interactively,
  304. with a prefix argument, you will be prompted for the coding system."
  305.   (interactive 
  306.    (list (get-library-path)
  307.      (if current-prefix-arg
  308.          (read-coding-system "Coding System: "))))
  309.   (find-file library codesys))
  310.  
  311. (defun find-library-other-window (library &optional codesys)
  312.   "Load the library named LIBRARY in another window.
  313. Under XEmacs/Mule, the optional second argument specifies the
  314. coding system to use when decoding the file.  Interactively,
  315. with a prefix argument, you will be prompted for the coding system."
  316.   (interactive 
  317.    (list (get-library-path)
  318.      (if current-prefix-arg
  319.        (read-coding-system "Coding System: "))))
  320.   (find-file-other-window library codesys))
  321. #+infodock (defalias 'lib-edit-other-window 'find-library-other-window)
  322.  
  323. (defun find-library-other-frame (library &optional codesys)
  324.   "Load the library named LIBRARY in a newly-created frame.
  325. Under XEmacs/Mule, the optional second argument specifies the
  326. coding system to use when decoding the file.  Interactively,
  327. with a prefix argument, you will be prompted for the coding system."
  328.   (interactive 
  329.    (list (get-library-path)
  330.      (if current-prefix-arg
  331.          (read-coding-system "Coding System: "))))
  332.   (find-file-other-frame library codesys))
  333.  
  334. ; This conflicts with an existing binding
  335. ;(define-key global-map "\C-xl" 'find-library)
  336. (define-key global-map "\C-x4l" 'find-library-other-window)
  337. (define-key global-map "\C-x5l" 'find-library-other-frame)
  338.  
  339. #+infodock (defalias 'lib-where-is 'locate-library)
  340.  
  341. #+infodock (provide 'lib)
  342. (provide 'lib-complete)
  343. ;;; lib-complete.el ends here
  344.